home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / env / env.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  6.7 KB  |  211 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (* env.sml *)
  3.  
  4. structure Env : ENV =
  5. struct
  6.   structure Symbol = 
  7.   struct
  8.     val varInt = 0 and sigInt = 1 and strInt = 2 and fsigInt = 3 and 
  9.         fctInt = 4 and tycInt = 5 and labInt = 6 and tyvInt = 7 and
  10.     fixInt = 8
  11.  
  12.     datatype symbol = SYMBOL of int * string
  13.     datatype namespace =
  14.        VALspace | TYCspace | SIGspace | STRspace | FCTspace | FIXspace |
  15.        LABspace | TYVspace | FSIGspace 
  16.     fun eq(SYMBOL(a1,b1),SYMBOL(a2,b2)) = a1=a2 andalso b1=b2
  17.     fun symbolGt(SYMBOL(_,s1), SYMBOL(_,s2)) = s1 > s2
  18.     fun varSymbol (name: string) =
  19.     SYMBOL(StrgHash.hashString name + varInt,name)
  20.     fun tycSymbol (name: string) =
  21.     SYMBOL(StrgHash.hashString name + tycInt, name)
  22.     fun fixSymbol (name: string) =
  23.     SYMBOL(StrgHash.hashString name + fixInt, name)
  24.     fun labSymbol (name: string) =
  25.     SYMBOL(StrgHash.hashString name + labInt, name)
  26.     fun tyvSymbol (name: string) =
  27.     SYMBOL(StrgHash.hashString name + tyvInt, name)
  28.     fun sigSymbol (name: string) =
  29.     SYMBOL(StrgHash.hashString name + sigInt, name)
  30.     fun strSymbol (name: string) =
  31.     SYMBOL(StrgHash.hashString name + strInt, name)
  32.     fun fctSymbol (name: string) =
  33.     SYMBOL(StrgHash.hashString name + fctInt, name)
  34.     fun fsigSymbol (name: string) =
  35.     SYMBOL(StrgHash.hashString name + fsigInt, name)
  36.     fun var'n'fix name =
  37.         let val h = StrgHash.hashString name
  38.      in (SYMBOL(h+varInt,name),SYMBOL(h+fixInt,name))
  39.     end
  40.     fun name (SYMBOL(_,name)) = name
  41.     fun number (SYMBOL(number,_)) = number
  42.     fun nameSpace (SYMBOL(number,name)) : namespace =
  43.     case number - StrgHash.hashString name
  44.       of 0 => VALspace
  45.            | 5 => TYCspace
  46.            | 1 => SIGspace
  47.            | 2 => STRspace
  48.            | 4 => FCTspace
  49.            | 8 => FIXspace
  50.            | 6 => LABspace
  51.            | 7 => TYVspace
  52.        | 3 => FSIGspace
  53.        | _ => ErrorMsg.impossible "Symbol.nameSpace"
  54.  
  55.     fun nameSpaceToString (n : namespace) : string =
  56.          case n
  57.          of VALspace => "variable or constructor"
  58.           | TYCspace => "type constructor"
  59.           | SIGspace => "signature"
  60.           | STRspace => "structure"
  61.           | FCTspace => "functor"
  62.           | FIXspace => "fixity"
  63.           | LABspace => "label"
  64.       | TYVspace => "type variable"
  65.       | FSIGspace => "functor signature"
  66.  
  67.     fun symbolToString(SYMBOL(number,name)) : string =
  68.         case number - StrgHash.hashString name
  69.           of 0 => "VAL$"^name
  70.            | 1 => "SIG$"^name
  71.            | 2 => "STR$"^name
  72.            | 3 => "FSIG$"^name
  73.            | 4 => "FCT$"^name
  74.            | 5 => "TYC$"^name
  75.            | 6 => "LAB$"^name
  76.            | 7 => "TYV$"^name
  77.        | 8 => "FIX$"^name
  78.            | _ => ErrorMsg.impossible "Symbol.makestring"
  79.   end
  80.  
  81.   structure FastSymbol = 
  82.     struct
  83.       local
  84.         open Symbol
  85.       in
  86.       type symbol = symbol
  87.       (* Another version of symbols but hash numbers have no increments
  88.        * according to their nameSpace *)
  89.       datatype raw_symbol = RAWSYM of int * string
  90.  
  91.       (* builds a raw symbol from a pair name, hash number *)
  92.       fun rawSymbol hash_name = RAWSYM hash_name
  93.  
  94.       (* builds a symbol from a raw symbol belonging to the same space as
  95.        * a reference symbol *)
  96.       fun sameSpaceSymbol (SYMBOL(i,s)) (RAWSYM(i',s')) =
  97.       SYMBOL(i' + (i - StrgHash.hashString s), s')
  98.  
  99.       (* build symbols in various name space from raw symbols *)
  100.       fun varSymbol (RAWSYM (hash,name)) =
  101.       SYMBOL(hash + varInt,name)
  102.       fun tycSymbol (RAWSYM (hash,name)) =
  103.       SYMBOL(hash + tycInt, name)
  104.       fun fixSymbol (RAWSYM (hash,name)) =
  105.       SYMBOL(hash + fixInt, name)
  106.       fun labSymbol (RAWSYM (hash,name)) =
  107.       SYMBOL(hash + labInt, name)
  108.       fun tyvSymbol (RAWSYM (hash,name)) =
  109.       SYMBOL(hash + tyvInt, name)
  110.       fun sigSymbol (RAWSYM (hash,name)) =
  111.       SYMBOL(hash + sigInt, name)
  112.       fun strSymbol (RAWSYM (hash,name)) =
  113.       SYMBOL(hash + strInt, name)
  114.       fun fctSymbol (RAWSYM (hash,name)) =
  115.       SYMBOL(hash + fctInt, name)
  116.       fun fsigSymbol (RAWSYM (hash,name)) =
  117.       SYMBOL(hash + fsigInt, name)
  118.       fun var'n'fix (RAWSYM (h,name)) =
  119.         (SYMBOL(h+varInt,name),SYMBOL(h+fixInt,name))
  120.       end
  121.     end;
  122.  
  123.   (* representation of environments *)
  124.   (* 'b will always be instantiated to Basics.binding *)
  125.   datatype 'b env
  126.     = EMPTY
  127.     | BIND of int * string * 'b * 'b env
  128.     | TABLE of 'b IntStrMap.intstrmap * 'b env
  129.     | OPEN of 'b env * ('b->'b) * 'b env
  130.     | SPECIAL of (Symbol.symbol -> 'b) * 'b env  (* for debugger *)
  131.  
  132.   exception Unbound = System.Unsafe.Assembly.UnboundTable
  133.  
  134.   exception SpecialEnv 
  135.     (* raised by app when it encounters a SPECIAL env *)
  136.  
  137.   val empty = EMPTY
  138.  
  139.   fun look (env,sym as Symbol.SYMBOL(is as (i,s))) = 
  140.     let fun f EMPTY = raise Unbound
  141.           | f (BIND(i',s',b,n)) =
  142.            if i = i' andalso s = s' then b else f n
  143.           | f (TABLE(t,n)) = (IntStrMap.map t is handle Unbound => f n)
  144.           | f (OPEN(e1,g,n)) = (g(look(e1,sym)) handle Unbound => f n)
  145.           | f (SPECIAL(g,n)) = (g sym handle Unbound => f n)
  146.     in f env
  147.     end
  148.  
  149.   fun bind (Symbol.SYMBOL(i,s),binding,env) = BIND (i,s,binding,env)
  150.   val open' = OPEN
  151.   val special = SPECIAL
  152.  
  153.   infix atop
  154.   fun EMPTY atop e = e
  155.     | (BIND(i,s,b,n)) atop e = BIND(i,s,b,n atop e)
  156.     | (TABLE(t,n)) atop e = TABLE(t,n atop e)
  157.     | (OPEN(e1,g,n)) atop e = OPEN(e1,g, n atop e)
  158.     | (SPECIAL(g,n)) atop e = SPECIAL(g, n atop e)
  159.  
  160.   fun app f =
  161.     let fun g (BIND(i,s,b,n)) = (g n; f (Symbol.SYMBOL(i,s),b))
  162.           | g (TABLE(t,n)) =
  163.           (g n; IntStrMap.app (fn (i,s,b) => f(Symbol.SYMBOL(i,s),b)) t)
  164.           | g (OPEN(e1,h,n)) = (g n; app (fn (s,b) => f(s, h b)) e1)
  165.       | g (SPECIAL _) = raise SpecialEnv
  166.       | g (EMPTY) = ()
  167.      in g
  168.     end
  169.  
  170.   fun map f (TABLE(t,EMPTY)) =  (* optimized case *)
  171.         TABLE(IntStrMap.transform f t, EMPTY)
  172.     | map f e =
  173.     let val t = IntStrMap.new(10,Unbound)
  174.      in app (fn (Symbol.SYMBOL(i,s),b) => IntStrMap.add t (i,s,f b)) e;
  175.         TABLE(t,EMPTY)
  176.     end
  177.  
  178.   fun consolidate e =
  179.       let open Symbol
  180.       fun f (BIND(i,s,b,n),c) =
  181.           let val t = f(n,c+1)
  182.            in IntStrMap.add t (i,s,b);
  183.           t
  184.           end
  185.         | f (TABLE(t,n),c) =
  186.           let val t' = f(n, c + IntStrMap.elems t)
  187.            in IntStrMap.app (IntStrMap.add t') t;
  188.           t'
  189.           end
  190.         | f (OPEN(e as TABLE(t,EMPTY),g,n),c) = 
  191.           let val t' = f(n,c+IntStrMap.elems t)
  192.            in IntStrMap.app (fn (i,s,b) => IntStrMap.add t' (i,s,g b)) t;
  193.           t'
  194.           end
  195.         | f (OPEN(e,g,n),c) = 
  196.           let val t = f(n,c+10 (*bogus, but just a hint*))
  197.            in app (fn (Symbol.SYMBOL(i,s), b) =>
  198.               IntStrMap.add t (i, s, g b))
  199.               e;
  200.           t
  201.           end
  202.         | f (SPECIAL(g,n),c) = raise SpecialEnv
  203.         | f (EMPTY,c) = IntStrMap.new (c,Unbound)
  204.        in TABLE(f(e,0),EMPTY) handle SpecialEnv => e
  205.       end
  206.  
  207. end (* structure Env *)
  208.  
  209. structure Symbol = Env.Symbol
  210. structure FastSymbol = Env.FastSymbol;
  211.